C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C    - REMOVE TABS
C    - PROGRAM UNITS RE-ORDERED
C    - ADDITIONAL YADEFS INCLUSIONS REMOVED
C    - DEFINES MOVED
C    - UNSPLIT LINES REMOVED
C    - CHANGE ZCTYPE TO ZPTYPE
C    - USE NEW TOKEN WRITE ROUTINE, CHANGE IODTKO/IODCMO FOR
C      TKNCHN AND USE ZTKPTI AS AN INITIALISATION CALL.
C
C--------   ISTSB.MAC
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
C
      PROGRAM ISTSB
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
      INTEGER TKNPTH(81),CIPTH(81),NWARN,NERROR,
     +          TKOPTH(81),CMOPTH(81),CMTPTH(81),JUNK
 
      INTEGER OPEN,CREATE,GETARG,ZYINCI,YPARSE,ZRENAM
      EXTERNAL OPEN,CREATE,ERROR,ZINIT,ZQUIT,ZYINSY,ZYINPT,ZMESS,
     +           GETARG,ZYINCI
      SAVE
        DATA (CIPTH(I),I=1,10)/35,
     +115,98,99,109,105,116,109,112,129/
 
      CALL ZINIT
 
      IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
      IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
      IF (GETARG(3,TKOPTH,81).EQ.-100) CALL NAMES(3,TKOPTH)
      IF (GETARG(4,CMOPTH,81).EQ.-100) CALL NAMES(4,CMOPTH)
 
      IODCMI = CREATE(CIPTH,2)
      IF (IODCMI.EQ.-1) CALL ERROR('Can''t create scratch file.')
 
  100 CONTINUE
      IODTKN=OPEN(TKNPTH,0)
      IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token stream.')
      IODCMT=OPEN(CMTPTH,0)
      IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment file.')
      IODTKO=CREATE(TKOPTH,1)
      IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token stream.')
      IODCMO=CREATE(CMOPTH,1)
      IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment stream.')
 
      CALL INISTR
      CALL INISYM
      CALL INITRE
      NERROR = 0
      NWARN = 0
      IF(YPARSE(IODTKN,IODCMT,-1,IODCMI,NERROR,NWARN).NE.0) CALL
     +   ERROR('[ISTSB - PARSER FATAL ERROR].')
 
      IF(NERROR .GT. 0) CALL ERROR('[ISTSB - PARSER ERRORS REPORTED].')
 
      CALL SEEK(0, IODCMI)
      CALL SEEK(0, IODCMT)
      IF(ZYINCI(IODCMI) .EQ. -1) CALL ERROR('[ISTSB - ZYINCI ERROR].')
 
C Initialize ITERAT in COMMON block REPEAT.
      ITERAT = .FALSE.
 
      CALL PROFIL
 
      IF (ITERAT) THEN
C*** EITHER USE THIS CODE (AUTOMATIC RE-PROCESSING)
         CALL ZMESS('[ ** Repeating ISTSB ** ].',2)
         CALL CLOSE(IODTKN)
         CALL CLOSE(IODCMT)
         CALL CLOSE(IODTKO)
         CALL CLOSE(IODCMO)
         CALL SEEK(0, IODCMI)
         CALL REMOVE(TKNPTH)
         CALL REMOVE(CMTPTH)
         IF(ZRENAM(TKOPTH, TKNPTH) .EQ. -1)
     +     CALL ERROR('[ISTSB - UNABLE TO RENAME TOKEN STREAM].')
         IF(ZRENAM(CMOPTH, CMTPTH) .EQ. -1)
     +     CALL ERROR('[ISTSB - UNABLE TO RENAME COMMENT STREAM].')
         GO TO 100
C*** OR THIS CODE (SINGLE OPERATION ONLY)
C*                 CALL ZMESS('[ISTSB Normal Termination].',stderr)
C*                 CALL ZMESS('[ ** Repeat ISTSB ** ].',stderr)
C*                 CALL ZQUIT(termflag_0)
C*** END-OF-SELECTION
 
      ELSE
         CALL CLOSE(IODCMI)
         CALL REMOVE(CIPTH)
         CALL ZMESS('[ISTSB Normal Termination].',2)
         CALL ZQUIT(-2)
      END IF
 
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE NAMES (NUMBER,PATH)
 
      INTEGER NUMBER,PATH(81)
 
      INTEGER ZGTCMD
      EXTERNAL ZGTCMD,ZPRMPT
 
      INTEGER JUNK,PROMPT(24,4)
 
      SAVE PROMPT
 
C "Input token stream:"
C "Input comment stream: "
C "Output token stream: "
C "Output comment stream: "
 
      DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
     +111,107,101,110,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
     +111,109,109,101,110,116,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
     +116,111,107,101,110,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,4),I=1,24)/79,117,116,112,117,116,32,
     +99,111,109,109,101,110,116,32,115,116,114,101,97,
     +109,58,32,129/
 
      CALL ZPRMPT(PROMPT(1,NUMBER))
      JUNK=ZGTCMD(PATH,0)
 
      END
C ----------------------------------------------------------------------
C
C       P R O F I L   -   Process files
C
 
      SUBROUTINE PROFIL
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
      INTEGER TEXT(134), SYMVAL(8)
      INTEGER ZYDOWN,ZYNEXT,ZYROOT,ZTKPTI,ZYGPUS
      COMMON /CLAB/ CURLBL,CURPUN,FIRST
      LOGICAL FIRST, FLAG
      INTEGER CURLBL,CURPUN,SNUM
 
      SAVE
 
      INTEGER PTR
 
      TKNCHN = ZTKPTI(1, IODTKO, IODCMO)
      IF(TKNCHN .EQ. -1) CALL ERROR('[ISTSB - Output Stream Failure].')
      CURPUN = 0
      PTR=ZYDOWN(ZYROOT())
 
      FLAG = .FALSE.
      SNUM = 1
 
 100  IF (PTR.GT.0) THEN
         CURLBL = 39999
         CURPUN = CURPUN + 1
         FIRST = .TRUE.
         CALL ZYGTSY(ZYGPUS(CURPUN), SYMVAL)
         CALL ZYGTST(SYMVAL(2), TEXT)
         CALL ZCHOUT('SB Processing: ', 2)
         CALL ZPTMES(TEXT, 2)
         CALL PROPU(FLAG, SNUM, PTR)
         PTR=ZYNEXT(PTR)
         GO TO 100
      END IF
 
      CALL ZTOKWR(TZEOF,0,TEXT,TKNCHN)
      CALL ZTKPTQ(TKNCHN)
 
      END
C--------   PROPU.MAC
C
C       P R O P U   -   Process Program-Unit
C
 
      SUBROUTINE PROPU(ASGN, SNUM,PUROOT)
      LOGICAL ASGN
      INTEGER PUROOT, SNUM
 
      INTEGER SPTR,NUMIN,NUMOUT,SEQLST(2000),SEQNR,
     +        TYPE,OKNO,POS1(30),POS2(30),
     +        POS3(30),NRNAMS,NAMES(7,30),I
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER ZYDOWN,ZYNEXT,NODETP,CONSUB
      EXTERNAL ZYDOWN,ZYNEXT,NODETP,YSTMT,COMOUT,PROSEQ,CONSUB
 
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
      SAVE
 
      NRNAMS = 0
      DO 10 I = 1, 30
         POS1(I) = 3
         POS2(I) = 3
         POS3(I) = 3
   10 CONTINUE
 
      SPTR=ZYDOWN(PUROOT)
 
  100 CONTINUE
      TYPE = NODETP(SPTR)
C Assignment statements for which 'no' is returned by CONSUB count as
C non-assignment statements for the purpose of determining the end of an
C assignment sequence.  However, an attempt will be made to start a new
C assignment sequence with such an assignment statement.
 
      IF (TYPE .EQ. 49) OKNO = CONSUB(SPTR,NAMES,POS1,POS2,
     +                                      POS3,NRNAMS)
 
      IF ((TYPE .NE. 49) .OR. (OKNO .EQ. -3)) THEN
C If this is the first non-assignment statement (or failure of the
C conditions tested by CONSUB) after an assignment sequence, process the
C assignment sequence.
 
         IF (ASGN) THEN
            CALL PROSEQ(SEQLST,SEQNR,NUMIN,NUMOUT)
C NUMOUT (output) is the number of the last statement in the sequence.
            SNUM = NUMOUT
            ASGN = .FALSE.
C Reinitialize the POSn, n=1,2,3 and NRNAMS.
            NRNAMS = 0
            DO 20 I = 1,30
               POS1(I) = 3
               POS2(I) = 3
               POS3(I) = 3
20            CONTINUE
         END IF
C If a failure of CONSUB was encountered, the offending assignment
C statement is not immediately output but first an attempt is made to
C start a new assignment sequence.
 
         IF (TYPE .NE. 49) THEN
              CALL YSTMT(SPTR,TKNCHN)
              SNUM=SNUM+1
            CALL COMOUT(SNUM)
         ELSE
            NRNAMS = 0
            DO 30 I = 1,30
               POS1(I) = 3
               POS2(I) = 3
               POS3(I) = 3
30            CONTINUE
            IF (CONSUB(SPTR,NAMES,POS1,POS2,POS3,NRNAMS) .EQ. -2) THEN
               SEQNR = 1
               ASGN = .TRUE.
C NUMIN is the number of the first statement in the sequence.
               NUMIN = SNUM
               SEQLST(SEQNR) = SPTR
            ELSE
                 CALL YSTMT(SPTR,TKNCHN)
                 SNUM=SNUM+1
               CALL COMOUT(SNUM)
            END IF
         END IF
      ELSE
C Statement is an assignment statement for which CONSUB returns 'ok'.
C If this is the first such assignment statement start an assignment
C sequence; otherwise, add the node to the active assignment sequence.
 
         IF (.NOT. ASGN) THEN
            SEQNR = 0
            ASGN = .TRUE.
C NUMIN is the number of the first statement in the sequence.
            NUMIN = SNUM
         END IF
C Add statement node to assignment sequence.
         SEQNR = SEQNR + 1
         SEQLST(SEQNR) = SPTR
      END IF
 
      SPTR=ZYNEXT(SPTR)
      IF (SPTR.NE.0) GOTO 100
 
      END
C--------   CONSUB.MAC
      INTEGER FUNCTION CONSUB(NODE,NAMES,POS1,POS2,POS3,NRNAMS)
 
      INTEGER NODE,NAMES(7,30),POS1(30),
     +          POS2(30),POS3(30),NRNAMS
 
C NRNAMS is the number of entries in the list NAMES of names of array
C elements.  POS1,POS2,POS3 contain, in the entry corresponding to an
C array name, either 'constant', 'variable', or 'nodim' according to
C whether the 1st, 2nd, and 3rd subscript positions for that array are
C constant, variable, or do not exist.  NOTE!! POS1, POS2, and POS3 MUST
C be initialized to 'nodim' and NRNAMS to 0 before the first call of
C CONSUB for each sequence of assignment statements.
 
C Given the assignment statement rooted at NODE, search for array
C elements on either side.  When one is found, determine whether its name
C is on the list NAMES.
C
C When an array element is found whose name is not on the list, add its
C name to the list, together with appropriate entries in POS1, POS2, and
C POS3.  Set CONSUB to 'ok' and continue.  If an entry with more than
C three dimensions is encountered, set CONSUB to 'no' and return.
C
C When an array element is found whose name is on the list, determine
C whether the each subscript is constant or variable as recorded.  If
C such is the case, set CONSUB to 'ok' and continue.  If some subscript
C is different, set CONSUB to 'no' and return.
C
C Thus, CONSUB returns 'no' if it discovers an array element with a
C subscript that is constant in one place and variable in another or vice
C versa, or if it discovers an array element with more than three
C dimensions.  Otherwise, CONSUB updates the lists and returns 'ok'.
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER POINTR,STACK(500),SUBPTR,ARNAME(7),
     +          NAMPTR,P1,P2,P3, I
 
      INTEGER NODETP,ZYDOWN,ZYNEXT,PUSH,POP,EQUAL
      EXTERNAL NODETP,ZYDOWN,ZYNEXT,PUSH,POP,EQUAL
 
      STACK(1) = -1
 
      IF (NODETP(NODE) .NE. 49) CALL ERROR('ISTSB: Input'
     +      //'Node Not An Assignment Statement.')
 
      POINTR = ZYDOWN(NODE)
30      CONTINUE
      IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('ISTSB: Stack Full.')
      IF (NODETP(POINTR) .EQ. 104) THEN
C Node is an array element.  Is its name on the list?
         NAMPTR = ZYDOWN(POINTR)
         CALL GETSTR(NAMPTR,ARNAME)
         DO 10 I = 1,NRNAMS
            IF (EQUAL(ARNAME,NAMES(1,I)) .EQ. -2) GO TO 20
10         CONTINUE
C Name is not on the list, enter it.
         NRNAMS = NRNAMS + 1
         CALL SCOPY(ARNAME,1,NAMES(1,NRNAMS),1)
C Determine the entries for the subscripts and enter them.
         SUBPTR = ZYNEXT(NAMPTR)
         IF (NODETP(SUBPTR) .EQ. 107) THEN
            POS1(NRNAMS) = 0
         ELSE
            POS1(NRNAMS) = 1
         END IF
         SUBPTR = ZYNEXT(SUBPTR)
         IF (SUBPTR .EQ. 0) THEN
            CONSUB = -2
            GO TO 60
         END IF
         IF (NODETP(SUBPTR) .EQ. 107) THEN
            POS2(NRNAMS) = 0
         ELSE
            POS2(NRNAMS) = 1
         END IF
         SUBPTR = ZYNEXT(SUBPTR)
         IF (SUBPTR .EQ. 0) THEN
            CONSUB = -2
            GO TO 60
         END IF
         IF (NODETP(SUBPTR) .EQ. 107) THEN
            POS3(NRNAMS) = 0
         ELSE
            POS3(NRNAMS) = 1
         END IF
         SUBPTR = ZYNEXT(SUBPTR)
         IF (SUBPTR .NE. 0) THEN
         CALL REMARK('CONSUB: Array Element With More Than'//
     +                  ' Three Dimensions.')
            CONSUB = -3
            RETURN
         END IF
20         CONTINUE
C Name of array element is on the list.  Check consistency of
C new appearance with information on list.
         P1 = 3
         P2 = 3
         P3 = 3
         SUBPTR = ZYNEXT(NAMPTR)
         IF (NODETP(SUBPTR) .EQ. 107) THEN
            P1 = 0
         ELSE
            P1 = 1
         END IF
         SUBPTR = ZYNEXT(SUBPTR)
         IF (SUBPTR .EQ. 0) GO TO 50
         IF (NODETP(SUBPTR) .EQ. 107) THEN
            P2 = 0
         ELSE
            P2 = 1
         END IF
         SUBPTR = ZYNEXT(SUBPTR)
         IF (SUBPTR .EQ. 0) GO TO 50
         IF (NODETP(SUBPTR) .EQ. 107) THEN
            P3 = 0
         ELSE
            P3 = 1
         END IF
50         CONTINUE
         IF ((POS1(I) .NE. P1) .OR. (POS2(I) .NE. P2) .OR.
     +         (POS3(I) .NE. P3)) THEN
            CONSUB = -3
            RETURN
         ELSE
            CONSUB = -2
         END IF
      END IF
60      CONTINUE
      POINTR = ZYDOWN(POINTR)
C If POINTR > 0, node is not a leaf. If POINTR = 0, node is an unnamed
C leaf.
      IF (POINTR .GT. 0) GO TO 30
C Node is a leaf.
      POINTR = POP(STACK)
C Can't go down; try next unless we have finished.
      IF(POINTR .EQ. NODE) THEN
         CONSUB = -2
         RETURN
      END IF
      POINTR = ZYNEXT(POINTR)
      IF(POINTR .GT. 0) GO TO 30
 
C Can't go next, pop until next is possible or return to NODE is complete.
        POINTR = POP(STACK)
      IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
         CONSUB = -2
         RETURN
      END IF
40      CONTINUE
      POINTR = ZYNEXT(POINTR)
      IF(POINTR .GT. 0) THEN
         GO TO 30
      ELSE
         POINTR = POP(STACK)
         IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
            CONSUB = -2
            RETURN
         END IF
         GO TO 40
      END IF
 
      END
C--------   PROSEQ.MAC
C -------------------------------------------------------------------
C      P R O S E Q - Process Assignment Sequence
C
      SUBROUTINE PROSEQ(LIST,NR,NUMF,NUML)
C Process the assignment sequence whose nodes are on LIST.
C There are NR statements in the sequence.  The first has statement
C number NUMF in the program unit.  The last has statement number
C NUML, which is output from PROSEQ.
 
      INTEGER LIST(*),NR,NUMF,NUML
 
      INTEGER LHSNOD,LPTR,NPTR,NXTNOD,SNUM,RHSNOD,I,COM1(66),
     +          DNODES(200),NRDEPS,DSET1(200),NRSET1,DSET2(200),
     +          NRSET2,TRYNOD,BUFFER,APTR,LALHS,COM2(28), J
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C THIS IS USED BY BOTH ISTSB AND ISTCD
C
C This COMMON block contains the logical variable ITERAT which is
C set to .TRUE. when a condition is encountered that implies that
C further processing is required on the parse tree obtained from
C the token stream output from the current run.  ZQUIT is called
C with condition 'repeat' if and only if ITERAT is .TRUE.
C
C This COMMON block contains the logical variables ITERAT and CYCLE.
 
      COMMON /REPEAT/ ITERAT,CYCLE
      LOGICAL ITERAT,CYCLE
 
      INTEGER ZYDOWN,NODETP,ZYNEXT,COMPAR,LENGTH
      EXTERNAL ZYDOWN,NODETP,ZYNEXT,COMPAR,COMOUT,YSTMT,YSTMTS,
     +           DEPSET,LENGTH
 
      SAVE
 
C "C*** Redefinition detected - substitution/elimination applied ***"
      DATA COM1/67,42,42,42,32,82,101,100,101,
     +            102,105,110,105,116,105,111,110,32,
     +            100,101,116,101,99,116,101,100,32,
     +            45,32,115,117,98,115,116,105,116,
     +            117,116,105,111,110,47,101,108,105,
     +            109,105,110,97,116,105,111,110,32,
     +            97,112,112,108,105,101,100,32,42,
     +            42,42,129/
 
C "C*** Statement permuted ***"
      DATA COM2/67,42,42,42,32,83,116,97,116,
     +            101,109,101,110,116,32,112,101,114,
     +            109,117,116,101,100,32,42,42,42,129/
 
      NPTR = 1
      LPTR = 1
      SNUM = NUMF
400      CONTINUE
C Candidate for redefinition is LIST(NPTR).
C Find its dependency set.
      CALL DEPSET(LIST(NPTR),DNODES,NRDEPS)
C Get node of lhs of candidate for redefinition.
         LHSNOD = ZYDOWN(LIST(NPTR))
      IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
 
C Process the sequence following LHSNOD.
100      CONTINUE
      LPTR = LPTR + 1
C Are we finished with the sequence following LHSNOD?
      IF (LPTR .GT. NR) GO TO 1500
 
900      CONTINUE
C LIST(LPTR) is the current statement in the sequence following the
C candidate for redefinition.
      NXTNOD = ZYDOWN(LIST(LPTR))
      IF (NODETP(NXTNOD) .EQ. 115) NXTNOD = ZYNEXT(NXTNOD)
 
C Test whether LIST(LPTR) is a redefinition.
      IF (COMPAR(NXTNOD,LHSNOD) .EQ. -2) THEN
C Redefinition found.  Output comment that transformation being applied
C and set flag to repeat ISTSB.
 
         CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
         ITERAT = .TRUE.
 
C Output statements from LIST(NPTR+1) to LIST(LPTR),
C with substitution of rhs of LIST(NPTR).
         RHSNOD = ZYNEXT(LHSNOD)
         DO 200 I = NPTR+1,LPTR
            CALL YSTMTS(LIST(I),LHSNOD,RHSNOD,TKNCHN)
            SNUM = SNUM + 1
            CALL COMOUT(SNUM)
200         CONTINUE
C Redefined statement not output - adjust comment pointer.
         SNUM = SNUM + 1
C Statement following LIST(LPTR) is new candidate for redefinition,
C unless we are at the end of the sequence.
         NPTR = LPTR + 1
         GO TO 1600
      END IF
C LIST(LPTR) is not a redefinition.  Determine whether it is an
C assignment to one of the names in the dependency set of LIST(NPTR).
 
      DO 500 I=1,NRDEPS
         IF (COMPAR(NXTNOD,DNODES(I)) .EQ. -2) GO TO 1200
500      CONTINUE
C LIST(LPTR) is not an assignment to a member of the dependency
C set of LIST(NPTR).
      GO TO 100
1200      CONTINUE
C LIST(LPTR) is an assignment to a member of the dependency set.  Look
C ahead in the assignment sequence for a redefinition.  If one is found,
C attempt to permute it upwards to immediately before LIST(LPTR).
 
C LIST(APTR) is the current statement in the look-ahead.
 
      APTR = LPTR + 1
1000      CONTINUE
C If we have exhausted the sequence looking for a redefinition,
C advance to the next candidate.
      IF (APTR .GT. NR) GO TO 1500
 
C Is LIST(APTR) a redefinition?
      LALHS = ZYDOWN(LIST(APTR))
      IF (NODETP(LALHS) .EQ. 115) LALHS = ZYNEXT(LALHS)
      IF (COMPAR(LALHS,LHSNOD) .NE. -2) THEN
C LIST(APTR) is not a redefinition.  Continue the search.
         APTR = APTR + 1
         GO TO 1000
      ELSE
C The look-ahead has found a redefinition.  See if it can be
C permuted upwards.
 
         CALL DEPSET(LIST(APTR),DSET1,NRSET1)
 
         DO 1400 I = LPTR,APTR-1
C Is the lhs of LIST(APTR) in the dependency set of LIST(I)?
C If so, proceed to the next candidate for redefinition.
            CALL DEPSET(LIST(I),DSET2,NRSET2)
            DO 700 J = 1,NRSET2
               IF (COMPAR(LALHS,DSET2(J)) .EQ. -2) GO TO 1500
700            CONTINUE
 
C Is the lhs of LIST(I) in the dependency set of LIST(APTR)?
C If so, proceed to the next candidate for redefinition.
            TRYNOD = ZYDOWN(LIST(I))
            IF (NODETP(TRYNOD) .EQ. 115) TRYNOD = ZYNEXT(TRYNOD)
            DO 800 J = 1,NRSET1
               IF (COMPAR(TRYNOD,DSET1(J)) .EQ. -2) GO TO 1500
800            CONTINUE
1400         CONTINUE
 
C Permute LIST(APTR) to immediately before the current LIST(LPTR).
         BUFFER = LIST(APTR)
         DO 1100 I = APTR-1,LPTR,-1
            LIST(I+1) = LIST(I)
1100         CONTINUE
         LIST(LPTR) = BUFFER
         CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
         GO TO 900
      END IF
 
1500      CONTINUE
C No redefinition possible, output candidate.
         CALL YSTMT(LIST(NPTR),TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
C Statement after candidate is new candidate for redefinition
C unless we are at end of sequence.
         NPTR = NPTR + 1
1600         CONTINUE
         IF (NPTR .GT. NR) THEN
            NUML = SNUM
            RETURN
         ELSE IF (NPTR .EQ. NR) THEN
            CALL YSTMT(LIST(NPTR),TKNCHN)
            SNUM = SNUM + 1
            CALL COMOUT(SNUM)
            NUML = SNUM
            RETURN
         ELSE
            LPTR = NPTR
            GO TO 400
         END IF
 
      END
